{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE RankNTypes                 #-}   
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE ExistentialQuantification  #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Language.Dependencies.References
-- Copyright   :  (c) 2009--2010 TU Dortmund
-- License     :  BSD3
--
-- Maintainer  :  menge@udo.cs.uni-dortmund.de
-- Stability   :  experimental
-- Portability :  non-portable
--
-- contains generic references and functions to deal with them (checking, 
-- adapting, persistence) functions. 
-----------------------------------------------------------------------------

module Language.Dependencies.References
   where

import Prelude hiding (readList, lookup,fst,snd)
import Text.ParserCombinators.Parsec
import Data.Char (isSpace)
import Data.Maybe
import Control.Monad

import Generics.MultiRec.Base
import Language.Dependencies.Zipper.PublicZipper 

-- * References Core

-- ** Data Types

-- | an abbreviation for functions like tonav 
type Nav phi ix= (Loc phi I0 ix -> Maybe (Loc phi I0 ix))

-- | Distiguishes depedit paths from GTK-TreeView-Paths 
data DPath = DPath [Int] deriving (Read)

-- | nicer addresses
data Address phi s t = Address
  { typerep :: phi s
  , value :: s
  , pathrep :: phi t
  , path :: DPath
  }


-- | references
data Reference  = forall phi1 phi2 s1 s2 t1 t2 . 
                  ( Fam phi2, Zipper phi2 (PF phi2), EqS phi2, 
                    Fam phi1, Zipper phi1 (PF phi1), EqS phi1 )
  => Reference
  { fstr :: Address phi1 s1 t1
  , sndr :: Address phi2 s2 t2
  , cmpr :: t1 -> t2 -> Bool
  }

-- | extracts a deep focus from a zipper locations or returns a type error
focus :: forall phi ix xi. (EqS phi) => phi ix -> (Loc phi I0 xi) -> ix
focus p (Loc q (I0 x) cs) = 
  case eqS p q of
    Just Refl -> x
    _   -> error "focus: type of focus doesnt match hole of location"

-- | convert paths to navigations
tonav :: DPath -> Nav phi ix
tonav (DPath path) = foldl (>=>) return (map tonav' path) where
  tonav' 0 = down
  tonav' i = tonav' (i-1) >=> right 

-- | explicit lookup
(@@) :: forall phi ix1 ix2. (Fam phi, Zipper phi (PF phi), EqS phi) 
     => (phi ix2,DPath)
     -> (phi ix1,ix1)
    -> ix2
(@@) (q,path) (p,e) = case (tonav path $ enter p e) of
  (Just l :: (Maybe (Loc phi I0 ix1))) -> focus q l
  Nothing -> error "invalid path"

-- | convenient lookup of addresses
lookup :: (Fam phi, Zipper phi (PF phi), EqS phi) => Address phi s t -> t
lookup a = (pathrep a, path a) @@ (typerep a, value a)


-- * The deep core

-- | parse -- locate -- compare: 
plc :: (Fam phi1, El phi1 ix1,
        Zipper phi1 (PF phi1), 
        Fam phi2, El phi2 ix2,
        Zipper phi2 (PF phi2))
       => phi1 ix1          -- p1 typerep needed to enter l1
       -> phi2 ix2          -- p2 typerep needed to enter l2
       -> ((String -> ix1)) -- a parse function for p1
       -> ((String -> ix2)) -- a parse function for p2
       -> (forall xi1 xi2. phi1 xi1 -> phi2 xi2 -> xi1 -> xi2 -> Bool)  -- a consistency function
       -> Relation -- paths and filepaths
       -> IO Bool
plc p1 p2 gp1 gp2 gc r@(Relation (Elem pf1 fp1) (Elem pf2 fp2) _) = do
       l1 <- fmap (fromJust . tonav pf1 . enter p1 . gp1) (readFile fp1)
       l2 <- fmap (fromJust . tonav pf2 . enter p2 . gp2) (readFile fp2)
       return $ (lcompare gc) l1 l2



-- | Higher Order Compare of zipper locations along the lines of 'on' 'update' and 'modify'
lcompare :: (forall xi1 xi2. phi1 xi1 -> phi2 xi2 -> xi1 -> xi2 -> Bool) 
        -> Loc phi1 I0 ix1 
        -> Loc phi2 I0 ix2 
        -> Bool
lcompare rel (Loc p1 (I0 x1) cs1) (Loc p2 (I0 x2) cs2) = rel p1 p2 x1 x2


-- * References 

-- | Specifies a list of relations between nodes
data Configuration = Configuration
  { relations :: [Relation]
  } deriving Show
  
-- | Specifies a comparision function that is identified by a string.
newtype CompareId = CompareId String 

instance Show DPath where
  show (DPath p) = show p

baseToInt :: [Int] -> Int -> Int
baseToInt is b = sum $ zipWith (safeMul b) (is) [b^i|i <- [0,1..]]
  
safeMul :: Int -> Int -> Int -> Int
safeMul c a b | a < c = a*b
safeMul c a b = error $ show a++"is a digit is larger than "++show c++"( at base "++show b++")"

-- | Specifies binary relations between nodes together with a 
--   consistency function
data Relation = Relation 
  { e1 :: Elem -- ^ first relation element
  , e2 :: Elem -- ^ second relation element
  , comparison :: CompareId -- ^ id of comparison function
  }

-- | Specifies an element of the relation.
data Elem = Elem
  { dpath :: DPath   -- ^ path in ast to a node 
  , filepath :: FilePath  -- ^ file containing the ast
  } 


instance Show Relation where
  show (Relation e1 e2 c) = show e1 ++" "++ show e2++ " ? "++ show c 

instance Show Elem where
  show (Elem p file) = show p ++ "@" ++ file

instance Show CompareId where
  show (CompareId s) = s  


-- ** A parser of data type configuration

remSpaces :: String -> String
remSpaces = filter (not.isSpace)

readConfig :: String -> Configuration
readConfig = Configuration . map readRelation . lines

readRelation :: String -> Relation
readRelation s = 
  let e1 = takeWhile (/=' ') s
      e2 = drop (1+length e1) $ takeWhile (/='?') s
      c = tail $ dropWhile (/='?') s in
  Relation 
    (readElem e1) 
    (readElem e2) 
    (CompareId $ filter (/=' ') c)

readElem :: String -> Elem
readElem s = 
  let (p,fp) = span (/='@') s in
  Elem (DPath $ parseIntList p) (remSpaces $ tail fp)
  
parseIntList :: [Char] -> [Int]
parseIntList = (read::String -> [Int])

